home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / packages / blink-paren.el.z / blink-paren.el
Encoding:
Text File  |  1998-05-21  |  6.5 KB  |  182 lines
  1. ;;; blink-paren.el --- blink the matching paren, just like Zmacs
  2. ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
  3.  
  4. ;; Author: devin@lucid.com.
  5. ;; Keywords: faces
  6.  
  7. ;; This file is part of XEmacs.
  8.  
  9. ;; XEmacs is free software; you can redistribute it and/or modify it
  10. ;; under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; XEmacs is distributed in the hope that it will be useful, but
  15. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17. ;; General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Synched up with: Not in FSF.
  25.  
  26. (defvar blink-paren-timeout 0.2
  27.   "*If the cursor is on a parenthesis, the matching parenthesis will blink.
  28. This variable controls how long each phase of the blink lasts in seconds.
  29. This should be a fractional part of a second (a float.)")
  30.  
  31. (defvar highlight-paren-expression nil
  32.   "*If true, highlight the whole expression of the paren under the cursor
  33. instead of blinking (or highlighting) the matching paren.  This will highlight
  34. the expression using the `highlight-expression' face.")
  35.  
  36. ;;; The blinking paren alternates between the faces blink-paren-on and
  37. ;;; blink-paren-off.  The default is for -on to look just like default
  38. ;;; text, and -off to be invisible.  You can change this so that, for
  39. ;;; example, the blinking paren fluctuates between bold and italic...
  40. ;;;
  41. ;;; You can make the matching paren merely be highlighted (and not blink)
  42. ;;; by setting the blink-paren-on and blink-paren-off faces to have the same
  43. ;;; attributes; if you do this, then emacs will not consume as much CPU.
  44. ;;;
  45. ;;; If highlight-paren-expression is true, then the whole sexp between the
  46. ;;; parens will be displayed in the `highlight-expression' face instead.
  47.  
  48. (make-face 'blink-paren-on)
  49. (make-face 'blink-paren-off)
  50. (make-face 'highlight-expression)
  51.  
  52. ;; extent used to change the face of the matching paren
  53. (defvar blink-paren-extent nil)
  54.  
  55. ;; timeout to blink the face
  56. (defvar blink-paren-timeout-id nil)
  57.  
  58. ;; find if we should look foward or backward to find the matching paren
  59. (defun blink-paren-sexp-dir ()
  60.   (cond ((and (< (point) (point-max))
  61.           (eq (char-syntax (char-after (point))) ?\())
  62.      1)
  63.     ((and (> (point) (point-min))
  64.           (eq (char-syntax (char-after (- (point) 1))) ?\)))
  65.      -1)
  66.     (t ())))
  67.  
  68. ;; make an extent on the matching paren if any.  return it.
  69. (defun blink-paren-make-extent ()
  70.   (let ((dir (blink-paren-sexp-dir)))
  71.     (and dir
  72.      (condition-case ()
  73.          (let* ((parse-sexp-ignore-comments t)
  74.             (other-pos (let ((pmin (point-min))
  75.                      (pmax (point-max))
  76.                      (point (point)))
  77.                  (unwind-protect
  78.                      (progn
  79.                        (narrow-to-region
  80.                     (max pmin (- point blink-matching-paren-distance))
  81.                     (min pmax (+ point blink-matching-paren-distance)))
  82.                        (forward-sexp dir) (point))
  83.                    (narrow-to-region pmin pmax)
  84.                    (goto-char point))))
  85.             (extent (if (= dir 1)
  86.                 (make-extent (if highlight-paren-expression
  87.                          (point)
  88.                            (- other-pos 1))
  89.                          other-pos)
  90.                   (make-extent other-pos
  91.                        (if highlight-paren-expression
  92.                            (point)
  93.                          (+ other-pos 1))))))
  94.            (set-extent-face extent (if highlight-paren-expression
  95.                        'highlight-expression
  96.                      'blink-paren-on))
  97.            extent)
  98.        (error nil)))))
  99.  
  100. ;; callback for the timeout
  101. ;; swap the face of the extent on the matching paren
  102. (defun blink-paren-timeout (arg)
  103.   ;; The extent could have been deleted for some reason and not point to a
  104.   ;; buffer anymore.  So catch any error to remove the timeout.
  105.   (condition-case ()
  106.       (set-extent-face blink-paren-extent 
  107.                (if (eq (extent-face blink-paren-extent)
  108.                    'blink-paren-on)
  109.                'blink-paren-off
  110.              'blink-paren-on))
  111.     (error (blink-paren-pre-command))))
  112.  
  113. ;; called after each command is executed in the post-command-hook
  114. ;; add the extent and the time-out if we are on a paren.
  115. (defun blink-paren-post-command ()
  116.   (blink-paren-pre-command)
  117.   (if (and (setq blink-paren-extent (blink-paren-make-extent))
  118.        (not highlight-paren-expression)
  119.        (not (and (face-equal 'blink-paren-on 'blink-paren-off)
  120.              (progn
  121.                (set-extent-face blink-paren-extent 'blink-paren-on)
  122.                t)))
  123.        (or (floatp blink-paren-timeout)
  124.            (integerp blink-paren-timeout)))
  125.       (setq blink-paren-timeout-id
  126.         (add-timeout blink-paren-timeout 'blink-paren-timeout ()
  127.              blink-paren-timeout))))
  128.  
  129. ;; called before a new command is executed in the pre-command-hook
  130. ;; cleanup by removing the extent and the time-out
  131. (defun blink-paren-pre-command ()
  132.   (condition-case c  ; don't ever signal an error in pre-command-hook!
  133.       (let ((inhibit-quit t))
  134.     (if blink-paren-timeout-id
  135.         (disable-timeout (prog1 blink-paren-timeout-id
  136.                    (setq blink-paren-timeout-id nil))))
  137.     (if blink-paren-extent
  138.         (delete-extent (prog1 blink-paren-extent
  139.                  (setq blink-paren-extent nil)))))
  140.     (error
  141.      (message "blink paren error! %s" c))))
  142.  
  143.  
  144. (defun blink-paren (&optional arg)
  145.   "Toggles paren blinking on and off.
  146. With a positive argument, turns it on.
  147. With a non-positive argument, turns it off."
  148.   (interactive "P")
  149.   (let* ((was-on (not (not (memq 'blink-paren-pre-command pre-command-hook))))
  150.      (on-p (if (null arg)
  151.            (not was-on)
  152.         (> (prefix-numeric-value arg) 0))))
  153.     (cond (on-p
  154.  
  155.        ;; in case blink paren was dumped, this needs to be setup
  156.        (or (face-differs-from-default-p 'blink-paren-off)
  157.            (progn
  158.          (set-face-background 'blink-paren-off (face-background 'default))
  159.          (set-face-foreground 'blink-paren-off (face-background 'default))))
  160.  
  161.        (or (face-differs-from-default-p 'highlight-expression)
  162.            (set-face-underline-p 'highlight-expression t))
  163.        
  164.        (add-hook 'pre-command-hook 'blink-paren-pre-command)
  165.        (add-hook 'post-command-hook 'blink-paren-post-command)
  166.        (setq blink-matching-paren nil))
  167.       (t
  168.        (remove-hook 'pre-command-hook 'blink-paren-pre-command)
  169.        (remove-hook 'post-command-hook 'blink-paren-post-command)
  170.        (and blink-paren-extent (detach-extent blink-paren-extent))
  171.        (setq blink-matching-paren t)))
  172.     on-p))
  173.  
  174. (defun blink-paren-init ()
  175.   "obsolete - use `blink-paren' instead."
  176.   (interactive)
  177.   (blink-paren 1))
  178.  
  179. (provide 'blink-paren)
  180.  
  181. (blink-paren 1)
  182.